home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / type / type-vars.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.3 KB  |  67 lines  |  [TEXT/CCL2]
  1. ;;; This type checks a variable.  Possible cases:
  2. ;;;  a) recursive variables
  3. ;;;  b) method variables
  4. ;;;  c) generalized variables 
  5. ;;;  d) other variables
  6.  
  7. ;;; Hacked to handle polymorphic recursion
  8.  
  9. (define-type-checker var-ref
  10.  (let* ((var (var-ref-var object))
  11.     (original-type (var-type var))
  12.     (type (if (and (recursive-type? original-type)
  13.                (not (eq? (recursive-type-rsig original-type) '#f)))
  14.           (recursive-type-rsig original-type)
  15.           original-type)))
  16.    (cond ((method-var? var)
  17. ;;; The context of a method variable always has the carrier class
  18. ;;; first.
  19.       (mlet (((ntype new-tyvars) (instantiate-gtype/newvars type))
  20.          (carrier-tyvar (car new-tyvars))
  21.          (extra-context (cdr new-tyvars))
  22.          (p (**method-placeholder
  23.              var carrier-tyvar (dynamic *enclosing-decls*) object))
  24.          (new-object (insert-dict-placeholders p extra-context object)))
  25.         (remember-placeholder p)
  26.         (return-type (**save-old-exp object new-object) ntype)))
  27.      ((recursive-type? type)
  28.       (let ((placeholder (**recursive-placeholder
  29.                   var (dynamic *enclosing-decls*))))
  30.         (push placeholder (recursive-type-placeholders type))
  31.         (return-type placeholder (recursive-type-type type))))
  32.      ((gtype? type)
  33.       (mlet (((ntype new-vars) (instantiate-gtype/newvars type))
  34.          (object1 (insert-dict-placeholders object new-vars object)))
  35.             (return-type (if (eq? object1 object)
  36.                  object
  37.                  (**save-old-exp object object1))
  38.              ntype)))
  39.      (else
  40.       (return-type object type)))))
  41.  
  42. ;;; This takes an expression and a context and returns an updated
  43. ;;; expression containing placeholders for the context information
  44. ;;; implied by the context.  Tyvars in the context are added to dict-vars.
  45.  
  46. (define (insert-dict-placeholders object tyvars var)
  47.   (cond ((null? tyvars)
  48.      object)
  49.     ((null? (ntyvar-context (car tyvars)))
  50.      (insert-dict-placeholders object (cdr tyvars) var))
  51.     (else
  52.      (let ((tyvar (car tyvars)))
  53.        (insert-dict-placeholders
  54.         (insert-dict-placeholders/tyvar
  55.          tyvar (ntyvar-context tyvar) object var)
  56.         (cdr tyvars)
  57.         var)))))
  58.  
  59. (define (insert-dict-placeholders/tyvar tyvar classes object var)
  60.   (if (null? classes)
  61.       object
  62.       (let ((p (**dict-placeholder
  63.          (car classes) tyvar (dynamic *enclosing-decls*) var)))
  64.     (remember-placeholder p)
  65.     (insert-dict-placeholders/tyvar tyvar (cdr classes) 
  66.                     (**app object p) var))))
  67.